#!/usr/bin/perl -w
use strict;
use Getopt::Long;

#88888888888888888888888888888888888888888888888888888888888888888888888888888888

#	Usage

#88888888888888888888888888888888888888888888888888888888888888888888888888888888

my $usage = <<'USAGE';

USAGE:

    split_pair_combinations.pl
                [--suffix output_file_suffix]
                [--prefix output_file_prefix]
                [--col_header]
                (files...)

    Accepts pairs of strings separated by tabs, each on one line.
    Prints out 4 files:
        1_to_1
        1_to_m
        m_to_1
        m_to_m
    The above file names can have supplied prefixes and suffixes
       i.e.
	   --suffix ".orthologs.data"
	   --prefix "/share/"
				would produce "/share/1_to_1.orthologs.data" etc.
    --col_header indicates that the first row is the column header
USAGE


#88888888888888888888888888888888888888888888888888888888888888888888888888888888888888888

#	Get options

#88888888888888888888888888888888888888888888888888888888888888888888888888888888888888888
# mandatory

# optional parameters
my $suffix = '';
my $prefix = '';
my $col_header;
my $help;
GetOptions(
			'prefix=s'			=> \$prefix,
			'suffix=s'			=> \$suffix,
			'col_header'		=> \$col_header,
			'help'				=> \$help);


die $usage if ($help);
die $usage unless (@ARGV);


# the two relationships for each pair
my %a_to_b;
my %b_to_a;
my @a_b;
if ($col_header)
{
	$col_header = <>;
}
#88888888888888888888888888888888888888888888888888888888888888888888888888888888

#	uniquify

#			removes duplicate entries in an array

#88888888888888888888888888888888888888888888888888888888888888888888888888888888
sub uniquify(\@)
{
	my %hash;
	@hash{@{$_[0]}} = ();
	@{$_[0]} = keys %hash;	
	return @{$_[0]};
}	

my @lines = <>;
# remove duplicates
my $non_unique_line_cnt = scalar @lines;
print STDERR "\t$non_unique_line_cnt\tpairs read\n";
uniquify(@lines);
print STDERR "\t", scalar @lines, "\tunique pairs read\n"
	if (scalar @lines != $non_unique_line_cnt);

print STDERR "\t\tFilling look up tables...\n";
for (@lines)
{
	chomp;
	my @pair = split /\t/;
	$a_to_b{$pair[0]}{$pair[1]}++;
	$b_to_a{$pair[1]}{$pair[0]}++;
	push(@a_b,  [$pair[0], $pair[1]]);
}

my @res_1_TO_1;
my @res_1_TO_M;
my @res_M_TO_1;
my @res_M_TO_M;

print STDERR "\t\tSorting by category...\n";
for (@a_b)
{
	my ($a,  $b) = @$_;
	# to many
	if (keys %{$a_to_b{$a}} > 1)
	{
		if (keys %{$b_to_a{$b}} > 1)
		{
			# many to many
			push (@res_M_TO_M,  "$a\t$b\n");
		}
		else
		{
			# one to many
			push (@res_1_TO_M,  "$a\t$b\n");
		}
	}
	# to one
	else
	{
		if (keys %{$b_to_a{$b}} > 1)
		{
			# many to one
			push (@res_M_TO_1,  "$a\t$b\n");
		}
		else
		{
			# one to one
			push (@res_1_TO_1,  "$a\t$b\n");
		}
	}
}

print STDERR "\t", '-'x6, "\n";
print STDERR "\t", scalar @res_1_TO_1, "\tone to one\n";
print STDERR "\t", scalar @res_1_TO_M, "\tone to many\n";
print STDERR "\t", scalar @res_M_TO_1, "\tmany to one\n";
print STDERR "\t", scalar @res_M_TO_M, "\tmany to many\n";
if (@res_1_TO_1)
{
	open FILE_1_TO_1, ">$prefix"."1_to_1$suffix";
#	print FILE_1_TO_1 $col_header if ($col_header);
	print FILE_1_TO_1 @res_1_TO_1;
}
if (@res_1_TO_M)
{
	open FILE_1_TO_M, ">$prefix"."1_to_m$suffix";
#	print FILE_1_TO_M $col_header if ($col_header);
	print FILE_1_TO_M @res_1_TO_M;
}
if (@res_M_TO_M)
{
	open FILE_M_TO_M, ">$prefix"."m_to_m$suffix";
#	print FILE_M_TO_M $col_header if ($col_header);
	print FILE_M_TO_M @res_M_TO_M;
}
if (@res_M_TO_1)
{
	open FILE_M_TO_1, ">$prefix"."m_to_1$suffix";
#	print FILE_M_TO_1 $col_header if ($col_header);
	print FILE_M_TO_1 @res_M_TO_1;
}
